home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / lib / qsave.pl < prev    next >
Encoding:
Text File  |  1998-02-04  |  7.4 KB  |  307 lines
  1. /*  $Id: qsave.pl,v 1.8 1998/02/04 16:22:06 jan Exp $
  2.  
  3.     Designed and implemented by Jan Wielemaker
  4.     E-mail: jan@swi.psy.uva.nl
  5.  
  6.     Copyright (C) 1995 University of Amsterdam. All rights reserved.
  7. */
  8.  
  9. :- module(qsave,
  10.       [ qsave_program/1
  11.       , qsave_program/2
  12.       ]).
  13.  
  14. :- module_transparent
  15.     qsave_program/1,
  16.     qsave_program/2.
  17.  
  18. :- system_mode(on).
  19.  
  20. :- dynamic verbose/1.
  21.  
  22. %    qsave_program(+File, +[Options ...])
  23. %
  24. %    Make a saved state in file `File'.
  25.  
  26. qsave_program(File) :-
  27.     qsave_program(File, []).
  28.  
  29. qsave_program(FileSpec, Options0) :-
  30.     '$strip_module'(FileSpec, Module, File),
  31.     option(Options0, autoload/true, Autoload, Options1),
  32.     option(Options1, map/[],        Map,      Options2),
  33.     option(Options2, goal/[],       GoalTerm, Options3),
  34.     option(Options3, op/save,    SaveOps,  Options4),
  35.     (   GoalTerm == []
  36.     ->  Options = Options4
  37.     ;   term_to_atom(Module:GoalTerm, GoalAtom),
  38.         term_to_atom(GT, GoalAtom),
  39.         define_predicate(user:GT),
  40.         Options = [goal=GoalAtom|Options4]
  41.     ),
  42.     (   Autoload == true
  43.     ->  save_autoload
  44.     ;   true
  45.     ),
  46.     (   Map == []
  47.     ->  retractall(verbose(_))
  48.     ;   open(Map, write, Fd),
  49.         asserta(qsave:verbose(Fd))
  50.     ),
  51.     set_feature(saved_program, true),
  52.     $open_wic(File, Options),
  53.     system_mode(on),        % generate system modules too
  54.     save_modules,
  55.     save_records,
  56.     save_flags,
  57.     save_imports,
  58.     save_features,
  59.     (   SaveOps == save
  60.     ->  save_operators
  61.     ;   true
  62.     ),
  63. %    save_foreign_libraries,
  64.     system_mode(off),
  65.     $close_wic,
  66.     (   nonvar(Fd)
  67.     ->  close(Fd)
  68.     ;   true
  69.     ).
  70.  
  71. save_modules :-
  72.     forall(special_module(X), save_module(X)),
  73.     forall((current_module(X), \+ special_module(X)), save_module(X)).
  74.  
  75. special_module(system).
  76. special_module(user).
  77.  
  78. define_predicate(Head) :-
  79.     '$define_predicate'(Head), !.    % autoloader
  80. define_predicate(Head) :-
  81.     '$strip_module'(Head, _, Term),
  82.     functor(Term, Name, Arity),
  83.     throw(error(existence_error(procedure, Name/Arity), _)).
  84.  
  85.  
  86.          /*******************************
  87.          *          AUTOLOAD        *
  88.          *******************************/
  89.  
  90. save_autoload :-
  91.     autoload.
  92.  
  93.          /*******************************
  94.          *           MODULES        *
  95.          *******************************/
  96.  
  97. save_module(M) :-
  98.     $qlf_start_module(M),
  99.     feedback('~n~nMODULE ~w~n', [M]),
  100.     (   P = (M:H),
  101.         current_predicate(_, P),
  102.         \+ predicate_property(P, imported_from(_)),
  103.         \+ predicate_property(P, foreign),
  104.         functor(H, F, A),
  105.         feedback('~nsaving ~w/~d ', [F, A]),
  106.         save_attributes(P),
  107.         \+ predicate_property(P, (volatile)),
  108.         nth_clause(P, _, Ref),
  109.         feedback('.', []),
  110.         $qlf_assert_clause(Ref),
  111.         fail
  112.     ;   $qlf_end_part,
  113.         feedback('~n', [])
  114.     ).
  115.     
  116. pred_attrib(dynamic,       P, $set_predicate_attribute(P, dynamic,       1)).
  117. pred_attrib(volatile,      P, $set_predicate_attribute(P, volatile,      1)).
  118. pred_attrib(multifile,     P, $set_predicate_attribute(P, multifile,     1)).
  119. pred_attrib(transparent,   P, $set_predicate_attribute(P, transparent,   1)).
  120. pred_attrib(discontiguous, P, $set_predicate_attribute(P, discontiguous, 1)).
  121. pred_attrib(notrace,       P, $set_predicate_attribute(P, trace,         0)).
  122. pred_attrib(show_childs,   P, $set_predicate_attribute(P, hide_childs,   0)).
  123. pred_attrib(indexed(Term), P, M:index(Term)) :-
  124.     $strip_module(P, M, _).
  125.  
  126. save_attributes(P) :-
  127.     pred_attrib(Attribute, P, D),
  128.     predicate_property(P, Attribute),
  129.     (   Attribute = indexed(Term)
  130.     ->  \+(( arg(1, Term, 1),
  131.              functor(Term, _, Arity),
  132.          forall(between(2, Arity, N), arg(N, Term, 0))))
  133.     ;   true
  134.     ),
  135.     $add_directive_wic(D),
  136.     feedback('(~w) ', [Attribute]), 
  137.     fail.
  138. save_attributes(_).
  139.  
  140.          /*******************************
  141.          *          RECORDS        *
  142.          *******************************/
  143.  
  144. save_records :-
  145.     feedback('~nRECORDS~n', []),
  146.     (   current_key(X),
  147.         feedback('~n~t~8|~w ', [X, V]),
  148.         recorded(X, V, _),
  149.         feedback('.', []),
  150.         $add_directive_wic(recordz(X, V, _)),
  151.         fail
  152.     ;   true
  153.     ).
  154.  
  155.  
  156.          /*******************************
  157.          *          FLAGS        *
  158.          *******************************/
  159.  
  160. save_flags :-
  161.     feedback('~nFLAGS~n~n', []),
  162.     (   current_flag(X),
  163.         flag(X, V, V),
  164.         feedback('~t~8|~w = ~w~n', [X, V]),
  165.         $add_directive_wic(flag(X, _, V)),
  166.         fail
  167.     ;   true
  168.     ).
  169.  
  170.          /*******************************
  171.          *         IMPORTS        *
  172.          *******************************/
  173.  
  174. default_import(system, _, _) :- !, fail.
  175. default_import(To, Head, _) :-
  176.     $get_predicate_attribute(To:Head, (dynamic), 1), !,
  177.     fail.
  178. default_import(user, Head, _) :- !,
  179.     $default_predicate(user:Head, system:Head).
  180. default_import(To, Head, _From) :-
  181.     $default_predicate(To:Head, user:Head).
  182. default_import(To, Head, _From) :-
  183.     $default_predicate(To:Head, system:Head).
  184.  
  185. save_imports :-
  186.     feedback('~nIMPORTS~n~n', []),
  187.     (   predicate_property(M:H, imported_from(I)),
  188.         \+ default_import(M, H, I),
  189.         functor(H, F, A),
  190.         feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
  191.         $add_directive_wic(M:import(I:H)),
  192.         fail
  193.     ;   true
  194.     ).        
  195.  
  196.          /*******************************
  197.          *          FEATURES        *
  198.          *******************************/
  199.  
  200. save_features :-
  201.     feedback('~nFEATURES~n~n', []),
  202.     feature(Feature, Value),
  203.     \+ c_feature(Feature),
  204.     feedback('~t~8|~w: ~w~n', [Feature, Value]),
  205.     $add_directive_wic(set_feature(Feature, Value)),
  206.     fail.
  207. save_features.
  208.  
  209. c_feature(symbol_file).
  210. c_feature(compiled_at).
  211. c_feature(min_integer).
  212. c_feature(max_integer).
  213. c_feature(min_tagged_integer).
  214. c_feature(max_tagged_integer).
  215. c_feature(pipe).
  216. c_feature(readline).
  217. c_feature(dynamic_stacks).
  218. c_feature(open_shared_object).
  219. c_feature(save_program).
  220. c_feature(save).
  221. c_feature(c_ldflags).
  222. c_feature(c_cc).
  223. c_feature(c_staticlibs).
  224. c_feature(c_libs).
  225. c_feature(home).
  226. c_feature(version).
  227. c_feature(arch).
  228. c_feature(boot_file).
  229. c_feature(unix).
  230. c_feature(windows).
  231. c_feature(max_arity).
  232. c_feature(integer_rounding_function).
  233. c_feature(bounded).
  234.  
  235.          /*******************************
  236.          *         OPERATORS        *
  237.          *******************************/
  238.  
  239. save_operators :-
  240.     feedback('~nOPERATORS~n', []),
  241.     findall(op(P, T, N), current_op(P, T, N), Ops),
  242.     $reset_operators,
  243.     make_operators(Ops, Set),
  244.     findall(D, deleted_operator(Ops, D), Deleted),
  245.     append(Set, Deleted, Modify),
  246.     forall(member(O, Modify),
  247.            (   feedback('~n~t~8|~w ', [O]),
  248.            $add_directive_wic(O),
  249.            O)).
  250.  
  251. make_operators([], []).
  252. make_operators([Op|L0], [Op|L]) :-
  253.     Op = op(P, T, N),
  254.     \+ current_op(P, T, N), !,
  255.     make_operators(L0, L).
  256. make_operators([_|T], L) :-
  257.     make_operators(T, L).
  258.  
  259. deleted_operator(Ops, op(0, T, N)) :-
  260.     current_op(_, T, N),
  261.     \+ (  member(op(_, OT, N), Ops),
  262.           same_op_type(T, OT)
  263.        ).
  264.     
  265. same_op_type(T, OT) :-
  266.     op_type(T, Type),
  267.     op_type(OT, Type).
  268.  
  269. op_type(fx,  prefix).
  270. op_type(fy,  prefix).
  271. op_type(xfx, infix).
  272. op_type(xfy, infix).
  273. op_type(yfx, infix).
  274. op_type(yfy, infix).
  275. op_type(xf,  postfix).
  276. op_type(yf,  postfix).
  277.  
  278.          /*******************************
  279.          *       FOREIGN LIBRARIES    *
  280.          *******************************/
  281.  
  282. save_foreign_libraries :-
  283.     $c_current_predicate(_, shlib:reload_foreign_libraries), !,
  284.     feedback('~nFOREIGN LIBRARY HOOK~n', []),
  285.     $add_directive_wic(shlib:reload_foreign_libraries).
  286. save_foreign_libraries.
  287.  
  288.  
  289.          /*******************************
  290.          *           UTIL        *
  291.          *******************************/
  292.  
  293. feedback(Fmt, Args) :-
  294.     verbose(Fd), !,
  295.     format(Fd, Fmt, Args).
  296. %    flush_output(Fd).        % Real debugging only
  297. feedback(_, _).
  298.  
  299.  
  300. option(List, Name/_Default, Value, Rest) :- % goal = Goal
  301.     select(List, Name=Value, Rest), !.
  302. option(List, Name/_Default, Value, Rest) :- % goal(Goal)
  303.     Term =.. [Name, Value],
  304.     select(List, Term, Rest), !.
  305. option(List, _Name/Default, Default, List).
  306.     
  307.